home *** CD-ROM | disk | FTP | other *** search
/ MacWorld 1999 March - Disc 1 / Macworld (1999-03) (Disk 1).dmg / Shareware World / Utilities / Text Processing / Alpha / Tcl / SystemCode / textManip.tcl < prev    next >
Encoding:
Text File  |  1998-12-15  |  30.0 KB  |  1,101 lines  |  [TEXT/ALFA]
  1. #===========================================================================
  2. # Information about a selection or window.
  3. #===========================================================================
  4. proc wordCount {} {
  5.     if {[set chars [string length [set text [getSelect]]]]} {
  6.     set lines [expr {[lindex [posToRowCol [selEnd]] 0] - [lindex [posToRowCol [getPos]] 0]}]
  7.     set text [getSelect]
  8.     } else {
  9.     set chars [maxPos]
  10.     set lines [lindex [posToRowCol $chars] 0]
  11.     set text [getText [minPos] [maxPos]]
  12.     }
  13.     regsub -all {[!=;.,\(\#\=\):\{\"\}]} $text " " text
  14.     set words [llength $text]
  15.     alertnote [format "%d chars, %d words, %d lines" $chars $words $lines]
  16. }
  17.  
  18.  
  19. # FILE: sortLines.tcl
  20. #
  21. # last update: 15/12/1998 {8:28:53 pm}
  22. #
  23. # This version of sortLines has the option of ignoring blanks/whitespace (-b)
  24. # and case-insensitive sorting (-i), or reverse sorting:
  25. #     sortLines [-b] [-i] [-r]
  26.  
  27. # COPYRIGHT:
  28. #
  29. #    Copyright © 1992,1993 by David C. Black All rights reserved.
  30. #    Portions copyright © 1990, 1991, 1992 Pete Keleher. All Rights Reserved.
  31. #
  32. #    Redistribution and use in source and binary forms are permitted
  33. #    provided that the above copyright notice and this paragraph are
  34. #    duplicated in all such forms and that any documentation,
  35. #    advertising materials, and other materials related to such
  36. #    distribution and use acknowledge that the software was developed
  37. #    by David C. Black.
  38. #
  39. #    THIS SOFTWARE IS PROVIDED "AS IS" AND WITHOUT ANY EXPRESS OR
  40. #    IMPLIED WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED
  41. #    WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE.
  42. #
  43. ################################################################################
  44.  
  45. # AUTHOR
  46. #
  47. #    David C. Black
  48. #    GEnie:    D.C.Black
  49. #    Internet: black@mpd.tandem.com (preferred)
  50. #    USnail:   6217 John Chisum Lane, Austin, TX 78749
  51. #
  52. ################################################################################
  53.  
  54. proc reverseSort {} {sortLines -r}
  55.  
  56. proc sortLines {args} {
  57.     set b_flag [lsearch $args "-b"]
  58.     if {$b_flag != -1} {
  59.     set args [lreplace $args $b_flag $b_flag]
  60.     }
  61.     incr b_flag
  62.     
  63.     set i_flag [lsearch $args "-i"]
  64.     if {$i_flag != -1} {
  65.     set args [lreplace $args $i_flag $i_flag]
  66.     }
  67.     incr i_flag
  68.     
  69.     if {[lsearch $args "-r"] >= 0} {
  70.     set mode "-decreas"
  71.     } else {
  72.     set mode "-increas"
  73.     }
  74.     
  75.     set start [getPos]
  76.     set end  [selEnd]
  77.     if {[pos::compare $start == $end]} {
  78.     alertnote "You must highlight the section you wish to sort."
  79.     return
  80.     }
  81.     if {[lookAt [pos::math $end - 1]] != "\r"} {
  82.     alertnote "The selection must consist only of complete lines."
  83.     return
  84.     }
  85.     set text [split [getText $start [pos::math $end - 1]] "\r"]
  86.     if {$b_flag > 0 || $i_flag > 0} {
  87.     foreach line $text {
  88.         if {$i_flag > 0} {
  89.         set key [string tolower $line]
  90.         } else {
  91.         set key $line
  92.         }
  93.         if {$b_flag > 0} {
  94.         regsub -all "\[ \t\]+" $key " " key
  95.         }
  96.         set orig($key) $line
  97.         lappend list $key
  98.     }
  99.     #endforeach
  100.     unset text
  101.     foreach key [lsort $mode $list] {
  102.         lappend text $orig($key)
  103.     }
  104.     #endforeach
  105.     } else {
  106.     set text [lsort $mode $text]
  107.     }
  108.     set text [join $text "\r"]
  109.     replaceText $start [pos::math $end - 1] $text
  110.     select $start $end
  111. }
  112. # Test case:
  113. #
  114. # a  black
  115. # a black cat
  116. # A  black dog
  117.  
  118.  
  119. ## 
  120.  # -------------------------------------------------------------------------
  121.  # 
  122.  # "sortParagraphs" --
  123.  # 
  124.  #  Sorts selected paragraphs according to their first 30 characters,
  125.  #  it's case insensitive and removes all non alpha-numeric characters
  126.  #  before the sort.
  127.  # -------------------------------------------------------------------------
  128.  ##
  129. proc sortParagraphs {args} {
  130.     set start [getPos]
  131.     set end  [selEnd]
  132.     if {[pos::compare $start == $end]} {
  133.     alertnote "You must highlight the section you wish to sort."
  134.     return
  135.     }
  136.     if {[lookAt [pos::math $end - 1]] != "\r"} {
  137.     alertnote "The selection must consist only of complete lines."
  138.     return
  139.     }
  140.     set text [getText $start $end]
  141.     if {[string first "•" $text] != -1} {
  142.     alertnote "Sorry, can't sort paragraphs with bullets '•'."
  143.     return
  144.     }
  145.     regsub -all "\[\r\n\]\[ \t\]*\[\r\n]" $text "\r•" text
  146.     set paras [split $text "•"]
  147.     unset text
  148.     # now each paragraph ends in \r
  149.     foreach para $paras {
  150.     set key [string tolower [string range $para 0 30]]
  151.     regsub -all {[^-a-z0-9]} $key "" key
  152.     # so we don't clobber duplicates!
  153.     while {[info exists orig($key)]} {append key "z"}
  154.     set orig($key) $para
  155.     }
  156.     unset para
  157.     foreach key [lsort [array names orig]] {
  158.     lappend text $orig($key)
  159.     }
  160.     replaceText $start $end [join $text "\r"]
  161.     select $start $end
  162. }
  163.  
  164.  
  165.  
  166. #================================================================================
  167. # Block shift left and right.
  168. #================================================================================
  169.  
  170. proc shiftLeft {} {
  171.     global shiftChar
  172.     doShiftLeft "\t"
  173.     
  174. }
  175. proc shiftLeftSpace {} {
  176.     global shiftChar
  177.     doShiftLeft " "
  178. }
  179.  
  180. proc doShiftLeft {shiftChar} {
  181.     set start [lineStart [getPos]]
  182.     set end [nextLineStart [pos::math [selEnd] - 1]]
  183.     if {[pos::compare $start >= $end]} {set end [nextLineStart $start]}
  184.     
  185.     set text [split [getText $start [pos::math $end - 1]] "\r\n"]
  186.     
  187.     set textout ""
  188.     
  189.     foreach line $text {
  190.     if {[string index $line 0] == $shiftChar} {
  191.         lappend textout [string range $line 1 end]
  192.     } else {
  193.         lappend textout $line
  194.     }
  195.     }
  196.     
  197.     set text [join $textout "\r"]    
  198.     replaceText $start [pos::math $end - 1] $text
  199.     select $start [pos::math $start + [expr {1 + [string length $text]}]]
  200. }
  201.  
  202.  
  203. proc shiftRight {} {
  204.     global shiftChar
  205.     doShiftRight "\t"
  206.     
  207. }
  208. proc shiftRightSpace {} {
  209.     global shiftChar
  210.     doShiftRight " "
  211. }
  212. proc doShiftRight {shiftChar} {
  213.     set start [lineStart [getPos]]
  214.     set end [nextLineStart [pos::math [selEnd] - 1]]
  215.     if {[pos::compare $start >= $end]} {set end [nextLineStart $start]}
  216.     
  217.     set text [split [getText $start [pos::math $end - 1]] "\r\n"]
  218.     
  219.     set textout ""
  220.     
  221.     foreach line $text {
  222.     lappend textout $shiftChar$line
  223.     }
  224.     
  225.     set text [join $textout "\r"]    
  226.     replaceText $start [pos::math $end - 1] $text
  227.     select $start [pos::math $start + [expr {1 + [string length $text]}]]
  228. }
  229.  
  230.  
  231.  
  232.  
  233.  
  234. proc selectAll {} {
  235.     select [minPos] [maxPos]
  236. }
  237.  
  238. # Select the next or current word. If word already selected, will go to next.
  239. proc hiliteWord {} {
  240.     if {[pos::compare [getPos] != [selEnd]]} forwardChar
  241.     forwardWord
  242.     set start [getPos]
  243.     backwardWord
  244.     select $start [getPos] 
  245. }
  246.  
  247. proc twiddle {} {
  248.     set pos [getPos]
  249.     if {[pos::compare $pos == [minPos]]} return
  250.     if {[pos::compare $pos == [maxPos]] || \
  251.       [pos::compare $pos == [pos::math [nextLineStart $pos] - 1]]} {
  252.     set incr -1
  253.     } else {
  254.     set incr 0
  255.     }
  256.     if {[string length [set text [getSelect]]]} {
  257.     if {[string length $text] == 1} {
  258.         return
  259.     } else {
  260.         set sel [pos::math [selEnd] + $incr]
  261.         set one [lookAt [pos::math $sel -1]]
  262.         set two [lookAt $pos]
  263.         replaceText $pos $sel "$one[getText [pos::math $pos + 1] [pos::math $sel - 1]]$two"
  264.         select $pos $sel
  265.         return
  266.     }
  267.     }
  268.     set pos [pos::math $pos + $incr]
  269.     set one [lookAt $pos]
  270.     set two [lookAt [pos::math $pos - 1]]
  271.     replaceText [pos::math $pos - 1] [pos::math $pos + 1] "$one$two"
  272.     select  [pos::math $pos - 1] [pos::math $pos + 1]
  273. }
  274.  
  275. proc twiddleWords {} {
  276.     global wordBreakPreface wordBreak
  277.     set pos [getPos]
  278.     if {[pos::compare $pos == [maxPos]] || $pos == [pos::math [nextLineStart $pos] - 1]} {
  279.     set eol 1
  280.     } else {
  281.     set eol 0
  282.     }
  283.     if {[pos::compare [getPos] != [selEnd]]} {
  284.     set start1 [getPos]; set end2 [selEnd]
  285.     select $start1
  286.     forwardWord; set end1 [getPos]
  287.     goto $end2
  288.     backwardWord; set start2 [getPos]
  289.     } else {
  290.     if {$eol} {
  291.         backwardWord; set pos [getPos]
  292.     }
  293.     select $pos
  294.     backwardWord; set start1 [getPos]
  295.     forwardWord; set end1 [getPos]
  296.     goto $pos
  297.     forwardWord; set end2 [getPos]
  298.     backwardWord; set start2 [getPos]
  299.     }        
  300.     
  301.     if {$start1 != $start2} {
  302.     set mid [getText $end1 $start2]
  303.     replaceText $start1 $end2 "[getText $start2 $end2]$mid[getText $start1 $end1]"
  304.     select $start1 $end2
  305.     }
  306. }
  307.  
  308. # proc commentLine {} {insertPrefix}
  309. proc commentLine {} {
  310.     global mode
  311.     global ${mode}::commentCharacters
  312.     if {![catch {commentCharacters Paragraph} chars]} {
  313.     set start [lindex $chars 0]
  314.     set end [lindex $chars 1]
  315.     if {[string trim $start] == [string trim $end]} {
  316.         insertPrefix
  317.     } else {
  318.         set ext  [file extension [win::CurrentTail]]
  319.         if {($mode == "C" || $mode == "C++") && $ext != ".h" && $ext != ".c"} {
  320.         insertPrefix
  321.         } else {
  322.         beginningOfLine
  323.         insertText $start
  324.         endOfLine
  325.         insertText $end
  326.         beginningOfLine
  327.         }
  328.     }
  329.     } else {
  330.     insertPrefix
  331.     }
  332. }
  333.  
  334. proc uncommentLine {} {removePrefix}
  335. proc insertPrefix {} {doPrefix insert}
  336. proc removePrefix {} {doPrefix remove}
  337. proc doPrefix {which} {
  338.     global prefixString
  339.     if {[pos::compare [set start [getPos]] == [set end [selEnd]]]} {
  340.     set end [nextLineStart $start]
  341.     }
  342.     set start [lineStart $start]
  343.     set text [getText $start $end]
  344.     replaceText $start $end [doPrefixText $which $prefixString $text]
  345.     goto $start
  346.     endOfLine
  347. }
  348.  
  349. proc quoteChar {} {
  350.     message "Literal keystroke to be inserted:"
  351.     insertText [getChar]
  352. }
  353.  
  354. proc setPrefix {} {
  355.     global prefixString
  356.     if {[catch {prompt "New Prefix String:" $prefixString} res] == 1} return
  357.     set prefixString $res
  358. }
  359.  
  360. proc setSuffix {} {
  361.     global suffixString
  362.     if {[catch {prompt "New Suffix String:" $suffixString} res] == 1} return
  363.     set suffixString $res
  364. }
  365.  
  366. proc insertSuffix {} {doSuffix insert}
  367. proc removeSuffix {} {doSuffix remove}
  368. proc doSuffix {which} {
  369.     global suffixString
  370.     set pts [getEndpts]
  371.     set start [lindex $pts 0]
  372.     set end [lindex $pts 1]
  373.     set start [lineStart $start]
  374.     set end [nextLineStart [pos::math $end - 1]]
  375.     set text [getText $start $end]
  376.     set text [doSuffixText $which $suffixString $text]
  377.     replaceText $start $end $text
  378.     select $start [getPos]
  379. }
  380.  
  381. proc commentBox {} {
  382.  
  383.     # Preliminaries
  384.     if {[commentGetRegion Box]} { return }
  385.     
  386.     set commentList [commentCharacters Box]
  387.     if { [llength $commentList] == 0 } { return }
  388.     
  389.     set begComment [lindex $commentList 0]
  390.     set begComLen [lindex $commentList 1]
  391.     set endComment [lindex $commentList 2]
  392.     set endComLen [lindex $commentList 3]
  393.     set fillChar [lindex $commentList 4]
  394.     set spaceOffset [lindex $commentList 5]
  395.  
  396.     set aSpace " "
  397.  
  398.     # First make sure we grab a full block of lines and adjust highlight
  399.  
  400.     set start [getPos]
  401.     set start [lineStart $start]
  402.     set end [selEnd]
  403.     set end [nextLineStart [pos::math $end - 1]]
  404.     select $start $end
  405.  
  406.     # Now get rid of any tabs
  407.     
  408.     if {[pos::compare $end < [maxPos]]} {
  409.     createTMark stopComment [pos::math $end + 1]
  410.     tabsToSpaces
  411.     gotoTMark stopComment
  412.     set end [pos::math [getPos] - 1]
  413.     removeTMark stopComment
  414.     } else {
  415.     tabsToSpaces
  416.     set end [maxPos]
  417.     }
  418.     select $start $end
  419.     set text [getText $start $end]
  420.     
  421. # Next turn it into a list of lines--possibly drop an empty 'last line'
  422.  
  423. # VMD May'95: changed this code segment because it
  424. # previously had problems with empty lines in the
  425. # middle of the text to be commented
  426.  
  427.     set lineList [split $text "\r\n"]
  428.     set ll [llength $lineList]
  429.     if { [lindex $lineList end] == {} } {
  430.     set lineList [lrange $lineList 0 [expr {$ll -2}] ]
  431.     }
  432.     set numLines [llength $lineList]
  433.  
  434. # end changes.
  435.     
  436. # Find the longest line length and determine the new line length
  437.  
  438.     set maxLength 0
  439.     foreach thisLine $lineList {
  440.     set thisLength [string length $thisLine]
  441.     if { $thisLength > $maxLength } { 
  442.         set maxLength $thisLength 
  443.     }
  444.     }
  445.     set newLength [expr {$maxLength + 2 + 2*$spaceOffset}]
  446.     
  447.     # Now create the top & bottom bars and a blank line
  448.  
  449.     set topBar $begComment
  450.     for { set i 0 } { $i < [expr {$newLength - $begComLen}] } { incr i } {
  451.     append topBar $fillChar
  452.     }
  453.     set botBar ""
  454.     for { set i 0 } { $i < [expr {$newLength - $endComLen}] } { incr i } {
  455.     append botBar $fillChar
  456.     }
  457.     append botBar $endComment
  458.     set blankLine $fillChar
  459.     for { set i 0 } { $i < [expr {$newLength - 2}] } { incr i } {
  460.     append blankLine " "
  461.     }
  462.     append blankLine $fillChar
  463.     
  464.     # For each line add stuff on left and spaces and stuff on right for box sides
  465.     # and concatenate everything into 'text'.  Start with topBar; end with botBar
  466.  
  467.     set text $topBar\r$blankLine\r
  468.     
  469.     set frontStuff $fillChar
  470.     set backStuff $fillChar
  471.     for { set i 0 } { $i < $spaceOffset } { incr i } {
  472.     append frontStuff " "
  473.     set backStuff $aSpace$backStuff
  474.     }
  475.     set backStuffLen [string length $backStuff]
  476.     
  477.     for { set i 0 } { $i < $numLines } { incr i } {
  478.     set thisLine [lindex $lineList $i ]
  479.     set thisLine $frontStuff$thisLine
  480.     set thisLength [string length $thisLine]
  481.     set howMuchPad [expr {$newLength - $thisLength - $backStuffLen}]
  482.     for { set j 0 } { $j < $howMuchPad } { incr j } {
  483.         append thisLine " "
  484.     }
  485.     append thisLine $backStuff
  486.     append text $thisLine \r
  487.     }
  488.     
  489.     append text $blankLine \r $botBar \r
  490.     
  491. # Now replace the old stuff, turn spaces to tabs, and highlight
  492.  
  493.     replaceText    $start $end    $text
  494.     set    end    [pos::math $start + [string length $text]]
  495.     frontSpacesToTabs $start $end
  496. }
  497.  
  498. proc uncommentBox {} {
  499.  
  500. # Preliminaries
  501.     if {[commentGetRegion Box 1]} { return }
  502.     
  503.     set commentList [commentCharacters Box]
  504.     if { [llength $commentList] == 0 } { return }
  505.     
  506.     set    begComment [lindex $commentList    0]
  507.     set    begComLen [lindex $commentList 1]
  508.     set    endComment [lindex $commentList    2]
  509.     set    endComLen [lindex $commentList 3]
  510.     set    fillChar [lindex $commentList 4]
  511.     set    spaceOffset    [lindex    $commentList 5]
  512.     
  513.     set aSpace " "
  514.     set aTab \t
  515.  
  516.     # First make sure we grab a full block of lines
  517.  
  518.     set start [getPos]
  519.     set start [lineStart $start]
  520.     set end [selEnd]
  521.     set end [nextLineStart [pos::math $end - 1]]
  522.     set text [getText $start $end]
  523.  
  524.     # Make sure we're at the start and end of the box
  525.  
  526.     set startOK [string first $begComment $text]
  527.     set endOK [string last $endComment $text]
  528.     set textLength [string length $text]
  529.     if { $startOK != 0 || ($endOK != [expr {$textLength-$endComLen-1}] || $endOK == -1) } {
  530.     alertnote "You must highlight the entire comment box, including the borders."
  531.     return
  532.     }
  533.     
  534.     # Now get rid of any tabs
  535.     
  536.     if {[pos::compare $end < [maxPos]] } {
  537.     createTMark stopComment [pos::math $end + 1]
  538.     tabsToSpaces
  539.     gotoTMark stopComment
  540.     set end [pos::math [getPos] - 1]
  541.     removeTMark stopComment
  542.     } else {
  543.     tabsToSpaces
  544.     set end [maxPos]
  545.     }
  546.     select $start $end
  547.     set text [getText $start $end]
  548.     
  549. # Next turn it into a list of lines--possibly drop an empty 'last line'
  550.  
  551. # VMD May'95: changed this code segment because it
  552. # previously had problems with empty lines in the
  553. # middle of the text to be commented
  554.  
  555.     set lineList [split $text "\n\r"]
  556.     set ll [llength $lineList]
  557.     if { [lindex $lineList end] == {} } {
  558.     set lineList [lrange $lineList 0 [expr {$ll -2}] ]
  559.     }
  560.     set numLines [llength $lineList]
  561.  
  562. # end changes.
  563.     
  564. # Delete the first and last lines, recompute number of lines
  565.  
  566.     set lineList [lreplace $lineList [expr {$numLines-1}] [expr {$numLines-1}] ]
  567.     set lineList [lreplace $lineList 0 0 ]
  568.     set numLines [llength $lineList]
  569.     
  570.     # Eliminate 2nd and 2nd-to-last lines if they are empty
  571.  
  572.     set eliminate $fillChar$aSpace$aTab
  573.     set thisLine [lindex $lineList [expr {$numLines-1}]]
  574.     set thisLine [string trim $thisLine $eliminate]
  575.     if { [string length $thisLine] == 0 } {
  576.     set lineList [lreplace $lineList [expr {$numLines-1}] [expr {$numLines-1}] ]
  577.     }
  578.     set thisLine [lindex $lineList 0]
  579.     set thisLine [string trim $thisLine $eliminate]
  580.     if { [string length $thisLine] == 0 } {
  581.     set lineList [lreplace $lineList 0 0 ]
  582.     }
  583.     set numLines [llength $lineList]    
  584.     
  585. # For each line trim stuff on left and spaces and stuff on right and splice
  586.  
  587.     set dropFromLeft [expr {$spaceOffset+1}]
  588.     set text ""
  589.     for { set i 0 } { $i < $numLines } { incr i } {
  590.     set thisLine [lindex $lineList $i]
  591.     set thisLine [string trimright $thisLine $eliminate]
  592.     set thisLine [string range $thisLine $dropFromLeft end]
  593.     set text $text$thisLine\r
  594.     }
  595.         
  596.     # Now replace the old stuff, convert spaces back to tabs
  597.  
  598.     replaceText    $start $end    $text
  599.     set end [pos::math $start + [string    length $text]]
  600.     frontSpacesToTabs $start $end
  601. }
  602.  
  603. ## 
  604.  # -------------------------------------------------------------------------
  605.  #     
  606.  # "commentCharacters" --
  607.  #    
  608.  #    Adds the 'general' purpose characters which
  609.  #    are    used to    check if we're in a    comment    block.
  610.  #    Also has a check for an array entry like this:
  611.  #    
  612.  #    set C++::commentCharacters(General) [list "*" "//"]
  613.  #    
  614.  #    If such an entry exists, it is returned.  This allows mode authors
  615.  #    to keep everything self-contained.
  616.  # -------------------------------------------------------------------------
  617.  ##
  618. proc commentCharacters {purpose} {
  619.     global mode commentCharacters
  620.     global ${mode}::commentCharacters
  621.     # allows a mode to define these things itself.
  622.     if {[info exists ${mode}::commentCharacters(${purpose})]} {
  623.     return [set ${mode}::commentCharacters(${purpose})]
  624.     }    
  625.     if {[info exists commentCharacters(${mode}:${purpose})]} {
  626.     return $commentCharacters(${mode}:${purpose})
  627.     }    
  628.     switch -- $purpose {
  629.     "General" {
  630.         switch -- $mode {
  631.         "TeX" {return "%" }
  632.         "Text" {return "!" }
  633.         "Fort" {return "C" }
  634.         "Scil" {return "//" }
  635.         "Perl" -
  636.         "Tcl" {return "\#" }
  637.         "C" {return "*" }
  638.         "Java" -
  639.         "C++" {return [list "*" "//"] }
  640.         "HTML" {return "<!--"}
  641.         default {
  642.             return
  643.         }
  644.         }
  645.     }        
  646.     "Paragraph" {        
  647.         switch -- $mode {
  648.         "TeX" {return [list "%% " " %%" " % "] }
  649.         "Text" {return [list "!! " " !!" " ! "] }
  650.         "Fort" {return [list "CC " " CC" " C "] }
  651.         "Scil" {return [list "//" "//" "//"] }
  652.         "Perl" -
  653.         "Tcl" {return [list "## " " ##" " # "] }
  654.         "Java" -
  655.         "C" -
  656.         "C++" {return [list "/* " " */" " * "] }
  657.         "HTML" { return [list "<!--" "-->" "|" ] }
  658.         default {
  659.             message "I don't know what comments should look like in this mode.  Sorry."
  660.             error "No comment characters"
  661.         }
  662.         }
  663.     }
  664.     "Box" {
  665.         switch -- $mode {
  666.         "TeX" {return [list "%" 1 "%" 1 "%" 3] }
  667.         "Text" {return [list "!" 1 "!" 1 "!" 3] }
  668.         "Fort" {return [list "C" 1 "C" 1 "C" 3] }
  669.         "Scil" {return [list "//" 2 "//"  2 "//" 3] }
  670.         "Perl" -
  671.         "Tcl" {return [list "#" 1 "#" 1 "#" 3] }
  672.         "Java" -
  673.         "C" -
  674.         "C++" {return [list "/*" 2 "*/" 2 "*" 3] }
  675.         "HTML" { return [list "<!--" 4 "-->" 3 "|" 3] }
  676.         default {
  677.             message "I don't know what comments should look like in this mode.  Sorry."
  678.             error "No comment characters"
  679.         }
  680.         }    
  681.     }
  682.     }    
  683.     
  684. }
  685.  
  686. ## 
  687.  # Default is to look for a    paragraph to comment out.
  688.  # If sent '1',    then we    look for a commented region    to 
  689.  # uncomment.
  690.  ##
  691. proc commentGetRegion { purpose {uncomment 0 } } {
  692.     if {[pos::compare [getPos] != [selEnd]]} {
  693.     watchCursor
  694.     return 0
  695.     }
  696.     
  697.     # there's no selection, so we try and generate one
  698.     
  699.     set pos [getPos]
  700.     if {$uncomment} {
  701.     # uncommenting
  702.     set commentList [commentCharacters $purpose]
  703.     if { [llength $commentList] == 0 } { return 1}
  704.     switch -- $purpose {
  705.         "Box" {
  706.         set begComment [lindex $commentList 0]
  707.         set begComLen [lindex $commentList 1]
  708.         set endComment [lindex $commentList 2]
  709.         set endComLen [lindex $commentList 3]
  710.         set fillChar [lindex $commentList 4]
  711.         set spaceOffset [lindex $commentList 5]
  712.         
  713.         # get length of current line
  714.         set line [getText [lineStart $pos] [nextLineStart $pos] ]
  715.         set c [string trimleft $line]
  716.         set slen [expr {[string length $line] - [string length $c]}]
  717.         set start [string range $line 0 [expr {$slen -1 }] ]
  718.                 
  719.         set pos [getPos]
  720.                 
  721.         if { $start == "" } {
  722.             set p $pos
  723.             while { [string first $fillChar $line] == 0 && \
  724.               [expr {[string last $fillChar $line] + [string length $fillChar]}] \
  725.               >= [string length [string trimright $line]] } {
  726.             set p [nextLineStart $p]
  727.             set line [getText [lineStart $p] [nextLineStart $p]]
  728.             }
  729.             set end [lineStart $p]
  730.             
  731.             set p $pos
  732.             set line "${fillChar}"
  733.             while { [string first $fillChar $line] == 0 && \
  734.               [expr {[string last $fillChar $line] + [string length $fillChar]}] \
  735.               >= [string length [string trimright $line]] } {
  736.             set p [prevLineStart $p]
  737.             set line [getText [prevLineStart $p] [lineStart $p] ]
  738.             }
  739.             set begin [prevLineStart $p]
  740.             
  741.         } else {
  742.             set line "$start"
  743.             set p $pos
  744.             while { [string range $line 0 [expr {$slen -1}] ] == "$start" } {
  745.             set p [nextLineStart $p]
  746.             set line [getText [lineStart $p] [nextLineStart $p]]
  747.             }
  748.             set end [prevLineStart $p]
  749.             
  750.             set p $pos
  751.             set line "$start"
  752.             while { [string range $line 0 [expr {$slen -1}] ] == "$start" } {
  753.             set p [prevLineStart $p]
  754.             set line [getText [prevLineStart $p] [lineStart $p] ]
  755.             }
  756.             set begin [lineStart $p]
  757.         }
  758.         
  759.         set beginline [getText $begin [nextLineStart  $begin]]
  760.         if { [string first "$begComment" "$beginline" ] != $slen } {
  761.             message "First line failed"
  762.             return 1
  763.         }
  764.         
  765.         set endline [getText $end [nextLineStart $end]]
  766.         set epos [string last "$endComment" "$endline"]
  767.         incr epos [string length $endComment]
  768.         set s [string range $endline $epos end ]
  769.         set s [string trimright $s]
  770.         
  771.         if { $s != "" } {
  772.             message "Last line failed"
  773.             return 1
  774.         }
  775.         
  776.         set end [nextLineStart $end]
  777.         select $begin $end
  778.         #alertnote "Sorry auto-box selection not yet implemented"
  779.         }
  780.         "Paragraph" {
  781.         set begComment [lindex $commentList 0]
  782.         set endComment [lindex $commentList 1]
  783.         set fillChar [lindex $commentList 2]
  784.                 
  785.         ## 
  786.          # basic idea is search    back and forwards for lines
  787.          # that    don't begin    the    same way and then see if they
  788.          # match the idea of the beginning and end of a    block
  789.          ##
  790.         
  791.         set line [getText [lineStart $pos] [nextLineStart $pos] ]
  792.         set chk [string range $line 0 [string first $fillChar $line]]
  793.         if { [string trimleft $chk] != "" } {
  794.             message "Not in a comment block"
  795.             return 1
  796.         }
  797.         regsub -all {    } $line " " line
  798.         set p [string first "$fillChar" "$line"]
  799.         set start [string range "$line" 0 [expr {$p + [string length $fillChar] -1}]]
  800.         set ll [commentGetFillLines $start]
  801.         set begin [lindex $ll 0]
  802.         set end [lindex $ll 1]
  803.         
  804.         set beginline [getText $begin [nextLineStart  $begin]]
  805.         if {[string first "$begComment" "$beginline" ] != $p } {
  806.             message "First line failed"
  807.             return 1
  808.         }
  809.                 
  810.         set endline [getText $end [nextLineStart $end]]
  811.         set epos [string last "$endComment" "$endline"]
  812.         incr epos [string length $endComment]
  813.         set s [string range $endline $epos end ]
  814.         set s [string trimright $s]
  815.         
  816.         if { $s != "" } {
  817.             message "Last line failed"
  818.             return 1
  819.         }
  820.         #goto $end
  821.         set end [nextLineStart $end]
  822.         select $begin $end
  823.         }
  824.     }
  825.     } else {
  826.     # commenting out
  827.     set searchString "^\[ \t\]*\$"
  828.     set searchResult1 [search -s -f 0 -r 1 -n $searchString $pos]
  829.     set searchResult2 [search -s -f 1 -r 1 -n $searchString $pos]
  830.     if {[llength $searchResult1]} {
  831.         set posStart [pos::math [lindex $searchResult1 1] + 1]
  832.     } else {
  833.         set posStart [minPos]
  834.     }
  835.     if {[llength $searchResult2]} {
  836.         set posEnd [lindex $searchResult2 0]
  837.     } else {
  838.         set posEnd [pos::math [maxPos] + 1]
  839.         goto [maxPos]
  840.         insertText "\n"
  841.     }
  842.     select $posStart $posEnd
  843.     }
  844.     
  845.     set str "Do you wish to "
  846.     if {$uncomment} { append str "uncomment" } else { append str "comment out" }
  847.     append str " this region?"
  848.     return [expr {![dialog::yesno $str]}]
  849. }
  850.  
  851.  
  852. proc prevLineStart { pos } {
  853.     return [lineStart [pos::math [lineStart $pos] - 1]]
  854. }
  855.  
  856. proc commentSameStart { line start } {
  857.     regsub -all "\t" "$line" " " line
  858.     if { [string first "$start" "$line"] == 0 } {
  859.     return 1
  860.     } else {
  861.     return 0
  862.     }
  863. }
  864.  
  865. proc commentGetFillLines { start } {
  866.     set pos [getPos]
  867.     regsub -all "\t" $start " " start
  868.     set line "$start"
  869.     
  870.     set p $pos
  871.     while { [commentSameStart "$line" "$start"] } {
  872.     set p [nextLineStart $p]
  873.     set line [getText [lineStart $p] [nextLineStart $p]]
  874.     }
  875.     set end [lineStart $p]
  876.     
  877.     set p $pos
  878.     set line "$start"
  879.     while { [commentSameStart "$line" "$start"] } {
  880.     set p [prevLineStart $p]
  881.     set line [getText [prevLineStart $p] [lineStart $p] ]
  882.     }
  883.     set begin [prevLineStart $p]
  884.     return [list $begin $end]
  885. }
  886.  
  887. ## 
  888.  # Author: Vince Darley    <mailto:darley@fas.harvard.edu> 
  889.  ##
  890.  
  891. proc commentParagraph {} {
  892.  
  893. # Preliminaries
  894.     if {[commentGetRegion Paragraph]} { return }
  895.     
  896.     set commentList [commentCharacters Paragraph]
  897.     if { [llength $commentList] == 0 } { return }
  898.  
  899.     set begComment [lindex $commentList 0]
  900.     set endComment [lindex $commentList 1]
  901.     set fillChar [lindex $commentList 2]
  902.     
  903.     
  904.     # First make sure we grab a full block of lines and adjust highlight
  905.     
  906.     set start [getPos]
  907.     set start [lineStart $start]
  908.     set end [selEnd]
  909.     set end [nextLineStart [pos::math $end - 1]]
  910.     select $start $end
  911.     
  912.     # Now get rid of any tabs
  913.     
  914.     if {[pos::compare $end < [maxPos]] } {
  915.         createTMark stopComment [pos::math $end + 1]
  916.         tabsToSpaces
  917.         gotoTMark stopComment
  918.         set end [pos::math [getPos] - 1]
  919.         removeTMark stopComment
  920.     } else {
  921.         tabsToSpaces
  922.         set end [maxPos]
  923.     }
  924.     select $start $end
  925.     set text [getText $start $end]
  926.     
  927. # Next turn it into a list of lines--possibly drop an empty 'last line'
  928.  
  929.     set lineList [split $text "\r\n"]
  930.     set ll [llength $lineList]
  931.     if { [lindex $lineList end] == {} } {
  932.         set lineList [lrange $lineList 0 [expr {$ll -2}] ]
  933.     }
  934.     set numLines [llength $lineList]
  935.     
  936.     # Find left margin for these lines
  937.     set lmargin 100
  938.     for { set i 0 } { $i < $numLines } { incr i } {
  939.         set l [lindex $lineList $i]
  940.         set lm [expr {[string length $l] - [string length [string trimleft $l]]}]
  941.         if { $lm < $lmargin } { set lmargin $lm }
  942.     }
  943.     set ltext ""
  944.     for { set i 0 } { $i < $lmargin } { incr i } {
  945.         append ltext " "
  946.     }
  947.     
  948.     # For each line add stuff on left and concatenate everything into 'text'. 
  949.     
  950.     set text ${ltext}${begComment}\r
  951.     
  952.     for { set i 0 } { $i < $numLines } { incr i } {
  953.         append text ${ltext} ${fillChar} [string range [lindex $lineList $i] $lmargin end] \r
  954.     }
  955.     append text ${ltext} ${endComment} \r
  956.     
  957.     # Now replace the old stuff, turn spaces to tabs, and highlight
  958.     
  959.     replaceText $start $end $text
  960.     set end [pos::math $start + [string length $text]]
  961.     frontSpacesToTabs $start $end
  962. }
  963.  
  964. ## 
  965.  # Author: Vince Darley    <darley@fas.harvard.edu>
  966.  ##
  967.  
  968. proc uncommentParagraph {} {
  969.  
  970.     # Preliminaries
  971.     if {[commentGetRegion Paragraph 1]} { return }
  972.     
  973.     set commentList [commentCharacters Paragraph]
  974.     if { [llength $commentList] == 0 } { return }
  975.     
  976.     set begComment [lindex $commentList 0]
  977.     set endComment [lindex $commentList 1]
  978.     set fillChar [lindex $commentList 2]
  979.     
  980.     set aSpace " "
  981.     set aTab \t
  982.     
  983.     # First make sure we grab a full block of lines and adjust highlight
  984.     
  985.     set start [getPos]
  986.     set start [lineStart $start]
  987.     set end [selEnd]
  988.     set end [nextLineStart [pos::math $end - 1]]
  989.     select $start $end
  990.     set text [getText $start $end]
  991.     
  992.     # Find left margin for these lines
  993.     set l [string range $text 0 [string first "\r" $text] ]
  994.     set lmargin [expr {[string length $l] - [string length [string trimleft $l]]}]
  995.     
  996.     # Make sure we're at the start and end of the paragraph
  997.  
  998.     set startOK [string first $begComment $text]
  999.     set endOK [string last $endComment $text]
  1000.     set textLength [string length $text]
  1001.     if { $startOK != $lmargin || ($endOK != [expr {$textLength-[string length $endComment]-1}] || $endOK == -1) } {
  1002.         alertnote "You must highlight the entire comment paragraph, including the tail ends."
  1003.         return
  1004.     }
  1005.     
  1006.     # Now get rid of any tabs
  1007.     
  1008.     if {[pos::compare $end < [maxPos]]} {
  1009.         createTMark stopComment [pos::math $end + 1]
  1010.         tabsToSpaces
  1011.         gotoTMark stopComment
  1012.         set end [pos::math [getPos] - 1]
  1013.         removeTMark stopComment
  1014.     } else {
  1015.         tabsToSpaces
  1016.         set end [maxPos]
  1017.     }
  1018.     select $start $end
  1019.     set text [getText $start $end]
  1020.     
  1021.     # Next turn it into a list of lines--possibly drop an empty 'last line'
  1022.     
  1023.     set lineList [split $text "\r\n"]
  1024.     set ll [llength $lineList]
  1025.     if { [lindex $lineList end] == {} } {
  1026.         set lineList [lrange $lineList 0 [expr {$ll -2}] ]
  1027.     }
  1028.     set numLines [llength $lineList]
  1029.     
  1030.     # Delete the first and last lines, recompute number of lines
  1031.     
  1032.     set lineList [lreplace $lineList [expr {$numLines-1}] [expr {$numLines-1}] ]
  1033.     set lineList [lreplace $lineList 0 0 ]
  1034.     set numLines [llength $lineList]
  1035.     
  1036.     # get the left margin
  1037.     set lmargin [string first $fillChar [lindex $lineList 0]]
  1038.     set ltext ""
  1039.     for { set i 0 } { $i < $lmargin } { incr i } {
  1040.         append ltext " "
  1041.     }
  1042.     
  1043.     # For each line trim stuff on left and spaces and stuff on right and splice
  1044.     set eliminate $fillChar$aSpace$aTab
  1045.     set dropFromLeft [expr {[string length $fillChar] + $lmargin}]
  1046.     set text ""
  1047.     for { set i 0 } { $i < $numLines } { incr i } {
  1048.         set thisLine [lindex $lineList $i]
  1049.         set thisLine [string trimright $thisLine $eliminate]
  1050.         set thisLine ${ltext}[string range $thisLine $dropFromLeft end]
  1051.         append text $thisLine \r
  1052.     }
  1053.     
  1054.     # Now replace the old stuff, turn spaces to tabs, and highlight
  1055.     
  1056.     
  1057.     replaceText    $start $end    $text
  1058.     set    end [pos::math $start + [string length $text]]
  1059.     frontSpacesToTabs $start $end
  1060. }
  1061.  
  1062.  
  1063. proc frontTabsToSpaces { start end } {
  1064.     select $start $end
  1065.     tabsToSpaces
  1066. }
  1067.  
  1068. proc frontSpacesToTabs { start end } {
  1069.     getWinInfo a
  1070.     set sp [string range "              " 1 $a(tabsize) ]
  1071.     set from [lindex [posToRowCol $start] 0]
  1072.     set to [lindex [posToRowCol $end] 0]
  1073.     while {$from <= $to} {
  1074.     set pos [rowColToPos $from 0]
  1075.     # get the leading whitespace of the current line
  1076.     set res [search -s -n -f 1 -r 1 "^\[ \t\]*" $pos]
  1077.     regsub -all "($sp| +\t)" [eval getText $res] "\t" front
  1078.     eval replaceText $res [list $front]
  1079.     incr from
  1080.     }
  1081. }
  1082.  
  1083. proc forwardDeleteUntil {{c ""}} {
  1084.     if {$c == ""} {
  1085.     message "Forward delete up to next:"
  1086.     set c [getChar]
  1087.     }
  1088.     set p [lindex [search -s -n -f 1 -r 1 [quote::Regfind $c] [getPos]] 0]
  1089.     if {$p != ""} {
  1090.     deleteText [getPos] [pos::math $p + 1]
  1091.     }
  1092. }
  1093.  
  1094. proc forwardDeleteWhitespace {} {
  1095.     set p [lindex [search -s -n -f 1 -r 1 {[^ \t\r\n]} [getPos]] 0]
  1096.     if {$p != ""} {
  1097.     deleteText [getPos] $p
  1098.     }
  1099. }
  1100.  
  1101.